home *** CD-ROM | disk | FTP | other *** search
/ TPUG - Toronto PET Users Group / TPUG Users Group CD / TPUG Users Group CD.iso / AMIGA / AMICUS / AMICUS25.ADF / KeyBird / KeyBirdSupportFile (.txt) < prev    next >
AmigaBASIC Source Code  |  1989-01-26  |  49KB  |  1,893 lines
  1. DEFINT a-z
  2. SCREEN 1,640,400,3,2
  3. WINDOW 2,"KEYBIRD (keyboard enhancer)",(0,8)-(631,186),16,1
  4. PALETTE 0,0.06,0.73,0.33         'green       (background)
  5. PALETTE 1,  1,  1,  1         'white       (foreground)
  6. PALETTE 2,0.5,0.5,  0.5         'light grey
  7. PALETTE 3,  0.78,  0,  0         'red  (=chosen)
  8. PALETTE 4,  0,  0,0.73         'blue (=not chosen)
  9. PALETTE 5, 1,  0.64,  0.64       'light red
  10. PALETTE 6,  0,  0,  0         'black
  11. PALETTE 7,0.46,  0.8,1         'light blue (menu text)
  12. REM   GOTO skipabove
  13. MENU 1,0,1,"Keybird Projects "
  14. MENU 2,0,1,""
  15. MENU 3,0,1,""
  16. MENU 4,0,1,""
  17. skipabove:
  18. black =     6   
  19. red =       3
  20. BLUE =      4
  21. lightred =  5
  22. lightblue = 7
  23. lightgrey = 2
  24. green     = 0
  25. white     = 1
  26. back      = lightblue
  27. cdt       = 28     'countdown 28 seconds
  28. textkey   = 127    'included here because printt needs it
  29. true = (1=1)
  30. false = (1=0)
  31. DIM SHARED clr(136),ulx(136),uly(136),lrx(136),lry(136)
  32. DIM SHARED nxt(136)
  33. textx=20:texty=8:CALL printt("Thanks for your patience...",1)
  34. COLOR 1,0
  35. ON TIMER(1) GOSUB timeslice
  36. TIMER ON
  37. ulx(0)=-2:uly(0)=-2  'fake out getkeycode
  38. CALL getkeycode(k,-1,-1)  'an early call to every subroutine helps amigabasic seem to run faster 
  39. GOSUB arrayallocation
  40. GOSUB constantdefinitions
  41. GOSUB statevariables
  42. GOTO  mainloop
  43. REM ********************************************************
  44. arrayallocation:
  45. REM ********************************************************
  46. DIM SHARED C$(136),c2$(119),texx(136),texy(136),reverse(7),otherchoice(7)
  47. DIM SHARED exp2(3),ml$(16)
  48. DIM SHARED keys(3,119,15),a$(119,15)
  49. DIM SHARED d(32),typ(119),num(15),use(16,15)
  50. DIM SHARED buff(2000),modi$(201),actionmsg$(12)
  51. REM 201 is 1 more than the maximum number of modifiable keys allowed
  52. DIM SHARED buffreloc$(200),clrextract(5,6)
  53. DIM SHARED deadcount(41),deadcode(41)
  54. REM 41 is 1 more than the maximum number of deadkeys allowed
  55. REM keys(1,k,0) is red or blue depending if k is capsable or not
  56. REM keys(2,k,0) is red or blue depending if k is repeatable or not
  57. REM keys(3,k,j) is a code combining info about deadkeys, modifiable, and
  58. RETURN
  59. REM *****************************************
  60. constantdefinitions:
  61. REM *****************************************  
  62. maxmod    = 201
  63. topdead   =  41
  64. active    = 1
  65. inactive  = 0
  66. dedkey=125
  67. modkey=126
  68. textkey=127
  69. actionkey=128
  70. modi$(0)  = "dummy"    'must have non-zero length
  71. reverse(black)     = lightgrey
  72. reverse(red)       = lightred
  73. reverse(BLUE)      = lightblue
  74. reverse(lightred)  = red
  75. reverse(lightblue) = BLUE
  76. reverse(lightgrey) = black
  77. otherchoice(red)   = BLUE
  78. otherchoice(lightred) = lightblue
  79. otherchoice(BLUE)  = red
  80. otherchoice(lightblue) = lightred
  81. exp2(0)=1
  82. exp2(1)=2
  83. exp2(2)=4
  84. exp2(3)=8
  85. wid =  15
  86. hei =  20
  87. keymap = 5
  88. modifiable = 4
  89. deadkeys = 3
  90. repeatable = 2
  91. capsable = 1
  92. mustextract = 3
  93. black.black.black  = 1
  94. red.blue.hardblue  = 2
  95. blue.red.hardblue  = 3
  96. blue.blue.hardblue = 4
  97. blue.blue.softblue = 5
  98. blue.blue.red      =6
  99. RESTORE extractdata
  100. FOR i=1 TO 6
  101.  FOR j=capsable TO keymap
  102.    READ clrextract(j,i)
  103.  NEXT j
  104.  READ comment$
  105. NEXT i
  106. extractdata:
  107. REM   capsable,repeatable,deadkeys,modifiable,keymap
  108. DATA  6,        6,        6,       6,         6,   i=1
  109. DATA  6,        6,        3,       4,         4,   i=2 (hardblue)
  110. DATA  3,        3,        4,       3,         4,   i=3 (hardblue)
  111. DATA  4,        4,        4,       4,         4,   i=4 (hardblue)
  112. DATA  6,        6,        4,       4,         4,   i=5 (softblue)
  113. DATA  6,        6,        4,       4,         3,   i=6   
  114. buffreserved = 2000
  115.   ml$(16)= "                  "
  116.   ml$(15)= "Dnup-Shft-Alt-Ctrl"
  117.   ml$(14)= "Downup-Alt-Ctrl   "
  118.   ml$(13)= "Downup-Shift-Ctrl "
  119.   ml$(12)= "Downup-Ctrl       "
  120.   ml$(11)= "Downup-Shift-Alt  "
  121.   ml$(10)= "Downup-Alt        "
  122.   ml$(9) = "Downup-Shift      "
  123.   ml$(8) = "Downup            "
  124.   ml$(7) = "Shift-Alt-Ctrl    "
  125.   ml$(6) = "Alt-Ctrl          "   
  126.   ml$(5) = "Shift-Ctrl        "
  127.   ml$(4) = "Ctrl              "
  128.   ml$(3) = "Shift-Alt         "
  129.   ml$(2) = "Alt               "
  130.   ml$(1) = "Shift             "
  131.   ml$(0) = "alone             "
  132.   actionmsg$(1) ="Make      Capsable  "
  133.   actionmsg$(2) ="Make NOT  Capsable  "
  134.   actionmsg$(3) ="Make      Repeatable"
  135.   actionmsg$(4) ="Make NOT  Repeatable"
  136.   actionmsg$(5) ="Make      DeadKey   "
  137.   actionmsg$(6) ="Make NOT  DeadKey   "
  138.   actionmsg$(7) ="Make      Modifiable"
  139.   actionmsg$(8) ="Make NOT  Modifiable"
  140.   actionmsg$(9) ="Make      Active    "
  141.   actionmsg$(10)="Make NOT  Active    "
  142.   actionmsg$(11)="No Action           "  
  143.   actionmsg$(12)="Make CLONEof Deadkey"
  144. FOR i=0 TO 136:nxt(i)=i+1:NEXT i
  145. nxt(0)=124              'for quick handling of commands
  146. nxt(124)=120            'keymap box overlaps 4 others, so
  147. nxt(123)=125            ' we must test it first
  148. nxt(135)=1              'now go back and pick up keyboard
  149. nxt(103)=136            'skip 104-119
  150. GOSUB setupnum
  151.   RESTORE keydata
  152.   READ a,b,C,d,e,comment$ 
  153.   WHILE a >= 0
  154.     ulx(a)=b
  155.     uly(a)=C
  156.     lrx(a)=d
  157.     lry(a)=e
  158.     C$(a) = comment$
  159.     IF a=136 THEN GOTO readnext
  160.     IF (a=71) OR (a=68) THEN
  161.        'do not plot a box
  162.     ELSE
  163.        LINE(ulx(a),uly(a))-(lrx(a),lry(a)),,b
  164.     END IF
  165. readnext:
  166.     READ a,b,C,d,e,comment$
  167.   WEND
  168. FOR i=0 TO 103
  169.     c2$(i) = MID$(C$(i),1,2)
  170.     texx(i) = (ulx(i)/8)+2
  171.     texy(i) = (uly(i)/8)+2
  172. NEXT i
  173. FOR i=120 TO 135
  174.     texx(i) = (ulx(i)/8)+2
  175.     texy(i) = (uly(i)/8)+2
  176. NEXT i
  177.     textx=texx(textkey):texty=texy(textkey)
  178. COLOR black,green  
  179. LOCATE 21,27:PRINT "Old:";
  180. LOCATE 22,27:PRINT "New:";
  181. MENU 1,0,1,"Keybird Project "
  182. MENU 1,1,1,"New  keymap     "
  183. MENU 1,2,1,"Load keymap     "
  184. MENU 1,3,1,"Save keymap     "
  185. MENU 1,4,1,"About           "
  186. MENU 1,5,1,"Quit            "
  187. MENU 1,0,0
  188. ON MENU GOSUB menuh
  189. ON MOUSE GOSUB leftmouse
  190. ON BREAK GOSUB breakh
  191. BREAK ON
  192. COLOR white,green:LOCATE 1,1:PRINT "End initialize"
  193. RETURN
  194. REM ********************************************************
  195. statevariables:
  196. REM ********************************************************
  197. f$="usa2"
  198. state = 1        'start in Capsable state
  199. q     = 0        'no qualifiers
  200. undefined = 999
  201. errno = 0
  202. action = undefined      ' action  make capsable
  203. txt=32
  204. text$ = ""
  205. numdead=0
  206. nummod=0
  207. maxdead   =  3
  208. clr(modkey) =  lightgrey
  209. clr(dedkey) =  lightgrey
  210. clr(textkey) = black
  211. kd    = undefined        'dedkey's keycode
  212. km    = undefined        'modkey's keycode
  213. kh    = undefined
  214. qd    = 0                'dedkey's qualstate
  215. qm    = 0                'modkey's qualstate
  216. helpstatus = inactive
  217. s$ = ""                  'queue for Ctrl-C
  218. FOR i=0 TO 103
  219.   typ(i)=0
  220.   keys(capsable,i,0) = BLUE
  221.   keys(repeatable,i,0) = BLUE
  222.   keys(mustextract,i,0) = blue.blue.red  'since we default to ??
  223.   FOR j=1 TO 15
  224.     keys(mustextract,i,j) = black.black.black
  225.   NEXT j
  226. NEXT i
  227. FOR i=1 TO maxmod
  228.   modi$(i)=""
  229. NEXT i
  230. FOR i=0 TO maxdead
  231.   deadcount(i)=0
  232.   deadcode(i)=0
  233. NEXT i
  234. st=state:IF st>3 THEN st=3
  235. FOR i=  0 TO 103
  236.   clr(i)=clrextract(state,keys(st,i,0))
  237.   FOR j=0 TO 15
  238.     a$(i,j) = "??"
  239.   NEXT j
  240. NEXT
  241. nil=FRE(0)
  242. FOR i=120 TO 136:clr(i)=black  :NEXT
  243. clr(120)=red
  244. FOR i=121 TO 124:clr(i)=BLUE:NEXT
  245. clr(actionkey) = BLUE
  246. FOR i=129 TO 131:clr(i)=black:NEXT
  247. FOR i=132 TO 135:clr(i)=black:NEXT
  248. FOR a=0 TO 103
  249.     z=clr(a)
  250.     GOSUB paintkey
  251. NEXT a
  252. FOR a=120 TO 135
  253.     IF a=124 THEN LINE(ulx(124),uly(124))-(lrx(124),lry(124)),,b
  254.     z=clr(a)
  255.     GOSUB paintkey
  256. NEXT a
  257. COLOR black,green
  258. LOCATE 18,27:PRINT "    ";   'Could be Mod or Use
  259. LOCATE 18,36:PRINT ml$(q);
  260. GOSUB erasededkey
  261. GOSUB actionchange
  262. nil=FRE(0)
  263. GOSUB clearlineone
  264. COLOR white,green:LOCATE 1,1:PRINT "Ready to go"
  265. MENU 1,0,1
  266. MENU ON
  267. MOUSE ON
  268. RETURN
  269. REM ********************************************************
  270. mainloop:
  271. REM ********************************************************   
  272.  IF s$<>"" THEN  
  273.    r$=s$:s$=""
  274.  ELSE
  275.    r$=INKEY$
  276.  END IF
  277.  IF r$ <> "" THEN
  278.    IF clr(textkey)=lightblue OR clr(textkey)=lightred THEN
  279.     GOSUB texth
  280.    ELSE
  281.     BEEP
  282.    END IF
  283.  END IF
  284.  nil=FRE(0)
  285.  SLEEP
  286.  GOTO mainloop
  287.  
  288. timeslice:
  289.   COLOR red,white:LOCATE 20,10
  290.   PRINT cdt;
  291.   cdt=cdt-1
  292.   COLOR 1,0
  293.   IF cdt<0 THEN LOCATE 20,10:PRINT "    ";:TIMER OFF
  294.   RETURN 
  295.  
  296. keydata:
  297. DATA  0, 15, 24, 45, 40,   `
  298. DATA  1, 45, 24, 75, 40,   1
  299. DATA  2, 75, 24,105, 40,   2
  300. DATA  3,105, 24,135, 40,   3
  301. DATA  4,135, 24,165, 40,   4
  302. DATA  5,165, 24,195, 40,   5
  303. DATA  6,195, 24,225, 40,   6
  304. DATA  7,225, 24,255, 40,   7
  305. DATA  8,255, 24,285, 40,   8
  306. DATA  9,285, 24,315, 40,   9
  307. DATA 10,315, 24,345, 40,   0
  308. DATA 11,345, 24,375, 40,   -
  309. DATA 12,375, 24,405, 40,   =
  310. DATA 13,405, 24,435, 40,   \
  311. REM  14 is undefined
  312. REM  15 is on keypad
  313. DATA 15,510, 72,570, 88,   0 p 
  314. DATA 16, 60, 40, 90, 56,   q
  315. DATA 17, 90, 40,120, 56,   w
  316. DATA 18,120, 40,150, 56,   e
  317. DATA 19,150, 40,180, 56,   r
  318. DATA 20,180, 40,210, 56,   t
  319. DATA 21,210, 40,240, 56,   y
  320. DATA 22,240, 40,270, 56,   u
  321. DATA 23,270, 40,300, 56,   i
  322. DATA 24,300, 40,330, 56,   o
  323. DATA 25,330, 40,360, 56,   p
  324. DATA 26,360, 40,390, 56,   [
  325. DATA 27,390, 40,420, 56,   ]
  326. REM  28 is undefined
  327. REM 29-31 are on keypad
  328. DATA 29,510, 56,540, 72,   1 p
  329. DATA 30,540, 56,570, 72,   2 p
  330. DATA 31,570, 56,600, 72,   3 p
  331. DATA 32, 75, 56,105, 72,   a
  332. DATA 33,105, 56,135, 72,   s
  333. DATA 34,135, 56,165, 72,   d
  334. DATA 35,165, 56,195, 72,   f
  335. DATA 36,195, 56,225, 72,   g
  336. DATA 37,225, 56,255, 72,   h
  337. DATA 38,255, 56,285, 72,   j
  338. DATA 39,285, 56,315, 72,   k
  339. DATA 40,315, 56,345, 72,   l
  340. DATA 41,345, 56,375, 72,   ;
  341. DATA 42,375, 56,405, 72,   '
  342. REM  43 and 44 are undefined
  343. REM 45-47 are on keypad
  344. DATA 45,510, 40,540, 56,   4 p
  345. DATA 46,540, 40,570, 56,   5 p
  346. DATA 47,570, 40,600, 56,   6 p
  347. REM  48 is undefined
  348. DATA 49, 90, 72,120, 88,   z
  349. DATA 50,120, 72,150, 88,   x
  350. DATA 51,150, 72,180, 88,   c
  351. DATA 52,180, 72,210, 88,   v
  352. DATA 53,210, 72,240, 88,   b
  353. DATA 54,240, 72,270, 88,   n
  354. DATA 55,270, 72,300, 88,   m
  355. DATA 56,300, 72,330, 88,  ","
  356. DATA 57,330, 72,360, 88,   .
  357. DATA 58,360, 72,390, 88,   /
  358. REM  59 is undefined
  359. REM 60 is on keypad
  360. DATA 60,570, 72,600, 88,   . p
  361. DATA 61,510, 24,540, 40,   7 p
  362. DATA 62,540, 24,570, 40,   8 p
  363. DATA 63,570, 24,600, 40,   9 p
  364. DATA 64,120, 88,360,104,   sp
  365. DATA 65,435, 24,480, 40,   bac
  366. DATA 66, 15, 40, 60, 56,   tab
  367. DATA 67,540, 88,600,104,   ent
  368. REM 68 is a special case   return
  369. REM we use 68 and 71 to cover it
  370. DATA 68,420, 40,450, 72,   ret
  371. DATA 69, 15,  8, 45, 24,   Esc
  372. DATA 70,450,  8,480, 24,   Del
  373. REM  71, 72, 73, 75 undefined
  374. DATA 71,405, 56,450, 72,   "  return kludge"
  375. REM 74 is on the pad
  376. DATA 74,510, 88,540,104,   - p
  377. DATA 76,450, 56,480, 72,   up 
  378. DATA 77,450, 88,480,104,   dwn 
  379. DATA 78,465, 72,495, 88,   rig
  380. DATA 79,435, 72,465, 88,   lef
  381. DATA 80, 60,  8, 90, 24,   F1
  382. DATA 81, 90,  8,120, 24,   F2
  383. DATA 82,120,  8,150, 24,   F3
  384. DATA 83,150,  8,180, 24,   F4
  385. DATA 84,180,  8,210, 24,   F5
  386. DATA 85,270,  8,300, 24,   F6
  387. DATA 86,300,  8,330, 24,   F7
  388. DATA 87,330,  8,360, 24,   F8
  389. DATA 88,360,  8,390, 24,   F9
  390. DATA 89,390,  8,420, 24,   F10
  391. REM 90, 91, 92, 93, 94 undefined
  392. DATA 95,450, 40,480, 56,   Hlp
  393. DATA 96, 15, 72, 90, 88,   SHl
  394. DATA 97,390, 72,435, 88,   SHr
  395. DATA 98, 45, 56, 75, 72,   cap
  396. DATA 99, 15, 56, 45, 72,   CTL
  397. DATA 100, 60, 88, 90,104,  ALl
  398. DATA 101,390, 88,420,104,  ALr
  399. DATA 102, 90, 88,120,104,  A l
  400. DATA 103,360, 88,390,104,  A r
  401. REM  104 to 119 undefined
  402. DATA 120, 15,112,105,144,  Capsable
  403. DATA 121,105,112,195,144,  Repeatable
  404. DATA 122, 15,144,105,176,  Deadkeys
  405. DATA 123,105,144,195,176,  Modifiable
  406. DATA 124, 60,128,150,160,  Keymap
  407. REM  next two, 125 and 126, are deadkey and modkey
  408. DATA 125,240,112,275,128,  ? 
  409. DATA 126,240,136,275,152,  ? 
  410. DATA 127,240,158,520,178,  This is a   32  character string
  411. DATA 128,435,112,525,144,  ActionKey
  412. REM delete: DATA 129,525,  0,600, 16,  Downup
  413. DATA 130,525,112,630,144,  Cycle Qualifiers
  414. DATA 131,525,144,630,176,  Cycle Active Qualifiers
  415. DATA 132,494,  0,524, 16,  DO
  416. DATA 133,524,  0,554, 16,  CT
  417. DATA 134,554,  0,584, 16,  AL
  418. DATA 135,584,  0,615, 16,  SH
  419. DATA 136,  0,  0,800,200,  Outrageous
  420. DATA -1,-1,-1,-1,-1,       end of data
  421.  
  422. subgetkeycode:
  423. SUB getkeycode(k,x,y) STATIC
  424. SHARED true, false
  425. found = false
  426. k=-1
  427. i=0
  428. WHILE NOT found
  429.    IF uly(i) > y  THEN GOTO iterate
  430.    IF ulx(i) = -1 THEN GOTO iterate
  431.    IF lry(i) <= y THEN GOTO iterate
  432.    IF ulx(i) > x  THEN GOTO iterate
  433.    IF lrx(i) <= x THEN GOTO iterate 
  434.    found = true
  435.    k=i
  436.    IF i=71 THEN k=68
  437. iterate: i=nxt(i)  
  438. WEND
  439. IF i=137 THEN k=-1  'remember, we iterated i
  440.                     'also, remember that i=136 is certain to succeed
  441. END SUB
  442.  
  443. paintkey:
  444. REM paint key with code a color z
  445.   IF a=71 THEN RETURN  'never color bottom of return key separately
  446.   LINE(ulx(a)+1,uly(a)+1)-(lrx(a)-1,lry(a)-1),z,bf
  447.   IF a=68 THEN LINE(ulx(71)+1,uly(71)+1)-(lrx(71)-1,lry(71)-1),z,bf
  448.   yp=texy(a) :  xp=texx(a)
  449.   LOCATE yp,xp
  450.   COLOR 1,z
  451.   IF a < 120 THEN
  452.    PRINT c2$(a);:RETURN
  453.   ELSEIF (a=122) OR (a=123) THEN  'Deadkeys or Modifiable
  454.    LOCATE yp+2,xp
  455.    PRINT C$(a);
  456.   ELSEIF (a=actionkey)  THEN
  457.    PRINT MID$(C$(a),1,10);
  458.    LOCATE yp+1,xp
  459.    PRINT MID$(C$(a),11,10);
  460.   ELSEIF (a=130) OR (a=131) THEN
  461.    LOCATE yp,xp
  462.    PRINT "Cycle";
  463.    LOCATE yp+1,xp
  464.    IF a=131 THEN PRINT "Active";:LOCATE yp+2,xp
  465.    PRINT "Qualifiers";
  466.   ELSEIF (a=textkey) THEN
  467.    texty=texty-1
  468.    CALL printt(C$(a),1)
  469.    texty=texty+1
  470.    COLOR 1,z:LOCATE yp,xp:PRINT SPACE$(32);
  471.   ELSE
  472.    PRINT C$(a);
  473.   END IF
  474. RETURN
  475.  
  476. setupnum:
  477.  RESTORE numdata  
  478.  FOR j=0 TO 15
  479.   READ num(j)
  480.   NEXT j
  481.  FOR i=1 TO 16
  482.   FOR j=0 TO 15
  483.   READ use(i,j)
  484.  NEXT j:NEXT i 
  485. numdata:
  486. REM cols. 0-7 correspond to the low hex
  487. REM  digit of the keytype
  488. REM entries of 99 mean "don't care"
  489. DATA  1, 2, 2, 4, 2, 4, 4, 8, 2, 4, 4, 8, 4, 8, 8,16
  490. DATA  0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0
  491. DATA 99, 1, 2, 1, 4, 1, 2, 1, 8, 1, 2, 1, 4, 1, 2, 1
  492. DATA 99,99,99, 2,99, 4, 4, 2,99, 8, 8, 2, 8, 4, 4, 2
  493. DATA 99,99,99, 3,99, 5, 6, 3,99, 9,10, 3,12, 5, 6, 3
  494. DATA 99,99,99,99,99,99,99, 4,99,99,99, 8,99, 8, 8, 4
  495. DATA 99,99,99,99,99,99,99, 5,99,99,99, 9,99, 9,10, 5
  496. DATA 99,99,99,99,99,99,99, 6,99,99,99,10,99,12,12, 6
  497. DATA 99,99,99,99,99,99,99, 7,99,99,99,11,99,13,14, 7
  498. DATA 99,99,99,99,99,99,99,99,99,99,99,99,99,99,99, 8
  499. DATA 99,99,99,99,99,99,99,99,99,99,99,99,99,99,99, 9
  500. DATA 99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,10
  501. DATA 99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,11
  502. DATA 99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,12
  503. DATA 99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,13
  504. DATA 99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,14
  505. DATA 99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,15
  506. RETURN
  507.  
  508. subopenup: 
  509.     GOSUB clearlineone
  510.     LOCATE 1,1:COLOR 1,0:PRINT "Read ";fff$;
  511.     ON ERROR GOTO diskerrorh:errno=0
  512.     OPEN fff$ FOR INPUT AS 1
  513.     IF errno <> 0 THEN ON ERROR GOTO 0:WINDOW OUTPUT 2:RETURN
  514.     RESTORE filedata
  515. REM *****************************************************    
  516. REM read hunk-header,length,start of next hunk, length
  517.     FOR i=1 TO 5*4
  518.       x$=INPUT$(1,#1)
  519.       READ b
  520. filedata:
  521. DATA  0,0,3,243,0,0,0,0,0,0,0,1,0,0,0,0
  522. DATA  0,0,0,0          
  523.       IF ASC(x$) <> b THEN
  524.          GOTO abort
  525.       END IF
  526.     NEXT i
  527. REM ******************************************************    
  528. REM read length of file    
  529.     x$=INPUT$(4,#1)   
  530.     filelength = CVL(x$)*4
  531.     header = 10+36+15+15+120
  532.     IF filelength-1 > buffreserved THEN
  533.        LOCATE 1,1:COLOR white,green
  534.        PRINT "Sorry, not enough buffer space reserved for this keymap.";
  535.        CLOSE #1:ON ERROR GOTO 0:RETURN
  536.     END IF
  537.     y$=INPUT$(4,#1)      'read 0,0,3,233
  538.     z$=INPUT$(4,#1)      'should be length of file
  539.     IF y$ <> CHR$(0)+CHR$(0)+CHR$(3)+CHR$(233) THEN abort
  540.     IF z$ <> x$ THEN abort
  541. REM ********************************************************
  542. REM read table
  543.     FOR i=0 TO filelength-1
  544.       buff(i) = ASC(INPUT$(1,#1))
  545.     NEXT i
  546. REM *******************************************************                     
  547. REM next 4 bytes should be hunk-reloc
  548.     x$=INPUT$(4,#1)
  549.     IF x$ <> CHR$(0)+CHR$(0)+CHR$(3)+CHR$(236) THEN
  550.        GOSUB clearlineone:LOCATE 1,1:COLOR white,green
  551.        PRINT "Did not find hunk-reloc where expected.";
  552.        CLOSE#1:ON ERROR GOTO 0:RETURN
  553.     END IF
  554. REM ********************************************************
  555. LOCATE 1,1:COLOR 1,0:PRINT "file ";f$;" read.  Now processing ...";
  556. CLOSE#1
  557. ON ERROR GOTO 0
  558. REM ********************************************************
  559. REM  initialize
  560. GOSUB clearlineone
  561. LOCATE 1,1:PRINT "                      first pass";
  562. FOR i=1 TO nummod
  563.   modi$(i)=""
  564. NEXT i  
  565. nummod=0
  566. numdead=0
  567. FOR i=0 TO maxdead
  568.   deadcount(i)=0
  569.   deadcode(i)=0
  570. NEXT i
  571. FOR i=0 TO 103
  572.    FOR j= 0 TO 15
  573.   keys(mustextract,i,j) = black.black.black
  574.   NEXT j
  575.   LOCATE 1,1:PRINT i;"     ";
  576. NEXT i
  577. nil=FRE(0)
  578. LOCATE 1,1:PRINT "                      second pass";
  579. REM interpret table
  580.     FOR i=0 TO 9
  581.        IF buff(i) <> 0 THEN GOTO abort
  582.     NEXT i    
  583. REM read 9 addresses
  584.     FOR i=0 TO 4*9-1
  585.       x=buff(i+10)  'skip past ten zeroes
  586.     NEXT i
  587. REM interpret caps table
  588.     j=0
  589.     FOR i=0 TO 14
  590.        x=buff(i+10+36) 'skip front stuff
  591.        FOR d=0 TO 7
  592.            y=x AND 1
  593.            IF y=0 THEN keys(capsable,j,0) = BLUE :ELSE keys(capsable,j,0) = red
  594.            j = j+1
  595.            x = (x-y)/2
  596.        NEXT d
  597.     NEXT i
  598. REM interpret repeat table
  599.     j=0
  600.     FOR i=0 TO 14
  601.       x=buff(i+10+36+15)
  602.       FOR d=0 TO 7
  603.           y=x AND 1
  604.           IF y=0 THEN keys(repeatable,j,0) = BLUE :ELSE keys(repeatable,j,0) = red
  605.           j = j + 1
  606.           x = (x-y)/2
  607.       NEXT d
  608.     NEXT i 
  609. REM interpret keytype table
  610.     FOR i=0 TO 119
  611.        x=buff(i+10+36+15+15)
  612.        typ(i)=x
  613.     NEXT i
  614. REM now set up the keymap
  615.   FOR i=0 TO 119
  616.     hihex=(typ(i) AND 240)/16   
  617.     lohex=typ(i) AND 15
  618.     IF (hihex AND 8) <> 0 THEN 'undefined key
  619.        typ(i)=undefined
  620.        GOTO wayout
  621.     ELSEIF (hihex AND 2) <> 0 THEN 'dead bit
  622.        typ(i)=lohex:C=num(lohex)
  623.        x$ = CHR$(buff(4*i+header))+CHR$(buff(4*i+header+1))+CHR$(buff(4*i+header+2))+CHR$(buff(4*i+header+3))
  624.        add=CVL(x$)
  625.        FOR j=0 TO 2*C-1
  626.          d(j)=buff(add+j)
  627.        NEXT j
  628.        FOR j=0 TO C-1
  629.         IF d(2*j)=0 THEN
  630.            x$=CHR$(d(2*j+1))
  631.            u = use(j+1,typ(i) AND 15)
  632.            a$(i,u) = x$
  633.            keys(mustextract,i,u) = blue.blue.hardblue
  634.         ELSEIF d(2*j)=1 THEN   'modifiable key
  635.            'make it identifiable in second pass
  636.            typ(i) = lohex OR 16
  637.            u = use(j+1,typ(i) AND 15)
  638.            keys(mustextract,i,u) = blue.red.hardblue       
  639.         ELSEIF d(2*j)=8 THEN   'dead key
  640.            u = use(j+1,typ(i) AND 15)
  641.            CALL adddeadkey(i,u,d(2*j+1),errcode)
  642.         ELSE
  643.           LOCATE 1,1:COLOR white,green
  644.           PRINT "***Abort***";
  645.           RETURN
  646.         END IF
  647.        NEXT j
  648.        GOTO wayout  
  649.     ELSEIF hihex=0  THEN     'ordinary key
  650.        IF (lohex=11) OR (lohex >=13) THEN 'direct
  651.           typ(i) = lohex:C=num(lohex)
  652.           x$=CHR$(buff(header+4*i))+CHR$(buff(header+4*i+1))+CHR$(buff(header+4*i+2))+CHR$(buff(header+4*i+3))
  653.           add=CVL(x$)
  654.           FOR j=0 TO C-1
  655.             x$=CHR$(buff(add+j))
  656.             u=use(j+1,lohex)
  657.             a$(i,u)=x$
  658.             keys(mustextract,i,u) = blue.blue.softblue
  659.           NEXT j
  660.        ELSEIF lohex <> 7 THEN        'immediate
  661.           typ(i) = lohex:C=num(lohex)
  662.           FOR j=0 TO C-1
  663.              x$=CHR$(buff(4*i+header+3-j))
  664.              u=use(j+1,lohex)
  665.              a$(i,u) = x$
  666.              keys(mustextract,i,u) = blue.blue.softblue
  667.           NEXT j
  668.        ELSE            'vanilla key   lohex=7
  669.           typ(i)=7
  670.           FOR j=0 TO 3
  671.               x$=CHR$(buff(4*i+header+3-j))
  672.               z$=CHR$(ASC(x$) AND 159)
  673.               a$(i,j) = x$
  674.               a$(i,j+4) = z$
  675.               keys(mustextract,i,j) = blue.blue.softblue
  676.               keys(mustextract,i,j+4) = blue.blue.softblue
  677.           NEXT j
  678.        END IF
  679.        GOTO wayout
  680.     ELSEIF hihex=4 THEN    'string
  681.        typ(i) = lohex
  682.        C = num(lohex)
  683.        x$ = CHR$(buff(4*i+header))+CHR$(buff(4*i+header+1))+CHR$(buff(4*i+header+2))+CHR$(buff(4*i+header+3))
  684.        add = CVL(x$) 
  685.        REM add       
  686.        REM array d holds the 2,4,6,8,10,12,14,or 16 byte string descriptor
  687.        FOR j=0 TO 2*C-1
  688.          d(j) = buff(add+j)
  689.        NEXT j
  690.        REM now assign the strings!
  691.        FOR j=0 TO C-1
  692.           x$=""
  693.           FOR h=add+d(2*j+1)  TO add+d(2*j+1)+d(2*j)-1
  694.               x$=x$+CHR$(buff(h))
  695.           NEXT h
  696.           u = use(j+1,typ(i))
  697.           a$(i,u) = x$
  698.           keys(mustextract,i,u)= blue.blue.red 
  699.        NEXT j
  700.        GOTO wayout
  701.     ELSE
  702.        LOCATE 1,1:COLOR white,green
  703.        PRINT "Keycode ";i;" is of unknown keytype ";typ(i)
  704.        PRINT "***Abort***";
  705.        GOSUB newk:RETURN
  706.     END IF
  707. wayout:    
  708.   LOCATE 1,1:PRINT i;"          "
  709.   NEXT i
  710. GOSUB clearlineone:LOCATE 1,1:PRINT "                      Third pass"  
  711. REM second pass, in which we handle modifiable keys
  712. REM we can identify the keycodes by their typ   
  713.   FOR i=0 TO 119
  714.     IF (typ(i) AND 16) <> 0 THEN
  715.        typ(i)= typ(i) AND 15
  716.        LOCATE 1,1:PRINT "redoing ";i;"       ";
  717.        x$ = CHR$(buff(4*i+header))+CHR$(buff(4*i+header+1))+CHR$(buff(4*i+header+2))+CHR$(buff(4*i+header+3))
  718.        add=CVL(x$)
  719.        C=num(typ(i))
  720.        FOR j=0 TO C-1
  721.          d(j) = buff(add+j)
  722.        NEXT j
  723.        FOR j=0 TO C-1
  724.          IF d(2*j)=1 THEN   'modifiable key
  725.             u=use(j+1,typ(i))
  726.             x$=""
  727.             FOR m=0 TO numdead
  728.               x$=x$ + CHR$(buff(add + d(2*j+1) + m))
  729.             NEXT m
  730.             nummod=nummod+1
  731.             modi$(nummod) = x$
  732.             a$(i,u) = CHR$(nummod)
  733.          END IF
  734.        NEXT j
  735.     END IF
  736.   NEXT i
  737. GOSUB clearlineone:LOCATE 1,1:PRINT "All finished   "  
  738.   RETURN
  739. abort:
  740.    LOCATE 1,1:COLOR white,green
  741.    PRINT "I cannot recognize ";f$;" as a keymap. ";
  742.    PRINT "***Abort***";
  743. RETURN
  744.  
  745. deadkeyh:
  746. SUB deletedeadkey(k,q) STATIC
  747. SHARED maxdead,numdead,mustextract,maxmod,nummod,blue.blue.softblue
  748.   j=ASC(a$(k,q))
  749.   IF deadcount(j) = 1 THEN 'whole way of life ends
  750.      deadcount(j)=0
  751.      dc=deadcode(j)
  752.      deadcode(j)=0
  753.      IF dc < numdead THEN
  754.        FOR m=0 TO maxdead - 1 'codes are always an initial segment 1..numdead
  755.          IF deadcode(m) > dc THEN deadcode(m)=deadcode(m)-1
  756.        NEXT m
  757.      END IF
  758.      numdead = numdead - 1
  759.      keys(mustextract,k,q) = blue.blue.softblue
  760.      a$(k,q)=" "
  761.      FOR m=1 TO nummod
  762.        modi$(m) = MID$(modi$(m),1,dc-1) +  MID$(modi$(m),dc+1,LEN(modi$(m))-dc)
  763.      NEXT m
  764.   ELSE       'a clone remains
  765.      deadcount(j)=deadcount(j)-1
  766.      keys(mustextract,k,q)=blue.blue.softblue
  767.      a$(k,q)=" "
  768.   END IF
  769. END SUB
  770.  
  771. SUB adddeadkey(k,q,dcode,errcode) STATIC
  772. SHARED red.blue.hardblue ,numdead,nummod ,mustextract
  773. SHARED maxdead
  774.   WINDOW OUTPUT 1:PRINT "add deadkey #",k;" ";C$(k);" q=";q;" dcode=";dcode
  775.   REM keycode k, qualstate q wants to be a deadkey
  776.   REM if dcode > 0 then it wants dcode to be its code
  777.   REM do this only if you know what you're doing,
  778.   REM because this wish is always honored
  779.   errcode = 0  'assume ok till proven otherwise
  780.   IF dcode > 0 THEN
  781.      REM see if we're just cloning an existing deadkey
  782.      j=0
  783.      WHILE (j<maxdead) AND (deadcode(j) <> dcode)
  784.         j=j+1
  785.      WEND
  786.      IF j<maxdead THEN  'deadcode(j)=dcode
  787.        keys(mustextract,k,q)=red.blue.hardblue
  788.        deadcount(j)=deadcount(j)+1
  789.  PRINT "clone of ";j;"  EXIT":WINDOW OUTPUT 2      
  790.        a$(k,q) = CHR$(j)
  791.        EXIT SUB
  792.      ELSE
  793.        'fall through to next section
  794.      END IF
  795.   END IF
  796.   REM first find an open slot in deadcount array
  797.   j=0
  798.   WHILE deadcount(j) <> 0  'guaranteed success at j=maxdead
  799.     j=j+1
  800.   WEND  
  801.   IF j=maxdead THEN
  802.      IF maxdead=topdead THEN
  803.        COLOR 1,0:LOCATE 1,1:PRINT "Sorry, I have no room to remember deadkeys.";
  804.        errcode=-1
  805.        EXIT SUB
  806.      ELSE
  807.        maxdead=maxdead+1
  808.        deadcode(maxdead)=0
  809.        deadcount(maxdead)=0
  810.      END IF  
  811.   END IF
  812.   REM  j<maxdead and is an open slot
  813.   deadcount(j)=1
  814.   IF dcode > 0 THEN
  815.      deadcode(j)=dcode
  816.      IF dcode > numdead THEN numdead=dcode
  817.   ELSE
  818.      numdead=numdead+1
  819.      deadcode(j)=numdead
  820.      FOR i=1 TO nummod                      'new in 48
  821.        modi$(i)=modi$(i)+MID$(modi$(i),1,1)
  822.      NEXT i
  823.   END IF
  824.   keys(mustextract,k,q) = red.blue.hardblue
  825.   a$(k,q)=CHR$(j) 
  826.   PRINT "numdead=";numdead;"EXIT"
  827.   WINDOW OUTPUT 2
  828. END SUB
  829.   
  830. leftmouse:
  831.   t=MOUSE(0)
  832.   x=MOUSE(1)
  833.   y=MOUSE(2)
  834.   CALL getkeycode(k,x,y)
  835.   IF k=-1 THEN
  836.    BEEP:GOSUB clearlineone
  837.   ELSEIF k < 120 THEN   'keyboard
  838.      GOSUB clearlineone
  839.      GOSUB keyboard
  840.   ELSE  
  841.     GOSUB clearlineone
  842.     IF clr(k)=black THEN BEEP:RETURN
  843.     ON (k-119) GOTO opth,opth,opth,opth,opth
  844.     ON (k-124) GOTO nowhere,nowhere,nowhere,actionh,nowhere
  845.     ON (k-129) GOTO cycleh,cycleh,qualh,qualh,qualh,qualh
  846.   END IF
  847.   RETURN
  848.   
  849. nowhere:
  850.   BEEP:RETURN  
  851. keyboard:
  852.     IF k=kh THEN 
  853.        'do nothing
  854.     ELSE
  855.       GOSUB highlightk     'Highlight new key (and bottom key)
  856.       GOSUB textchange     'fix text
  857.       GOSUB actionchange
  858.     END IF
  859.   RETURN
  860.   
  861. highlightk:
  862.   IF kh <> undefined THEN
  863.     z=reverse(clr(kh))  'In these 3 lines
  864.     a=kh
  865.     GOSUB paintkey      '   we "unhighlight" the previous
  866.     clr(kh)=z           '   highlighted key
  867.   END IF
  868.   z=reverse(clr(k))
  869.   a=k
  870.   GOSUB paintkey
  871.   clr(k)=z
  872.   kh = k
  873. REM copy result to modkey or dedkey as appropriate
  874. IF (state <> deadkeys) THEN
  875.   C$(modkey)=C$(k)
  876.   a=modkey 
  877.   GOSUB paintkey  
  878.   clr(modkey)=z
  879. ELSE    'state = deadkeys
  880.   C$(dedkey)=C$(k)
  881.   a=dedkey
  882.   GOSUB paintkey
  883.   clr(dedkey)=z
  884. END IF
  885.   RETURN
  886.   
  887. opth:
  888.   newstate = k-119
  889.   IF (newstate <  3) AND (state >= 3) THEN GOSUB qualoff
  890.   IF (newstate >= 3) AND (state <  3) THEN GOSUB qualon 
  891.   IF newstate=state THEN
  892.     'do nothing
  893.   ELSE
  894.     REM fix colors of option selectors 
  895.       z=otherchoice(clr(119+state))
  896.       IF state <> 5 THEN a=119+state:GOSUB paintkey
  897.       clr(119+state)=z
  898.       z = otherchoice(clr(119+newstate))
  899.       a=119+newstate
  900.       GOSUB paintkey
  901.       clr(119+newstate)=z     
  902.       IF newstate <> 5 THEN
  903.          a=124:z=clr(124)
  904.          GOSUB paintkey  'keymap key
  905.       END IF
  906.       COLOR 1,0:LINE(ulx(124),uly(124))-(lrx(124),lry(124)),,b 
  907.   END IF
  908.   oldstate=state
  909.   state=newstate
  910.   IF (state=deadkeys) AND (kd<>undefined) AND (q<>qd) THEN q=qd:GOSUB showqual    
  911.   GOSUB repaintkeytops
  912.   ON state GOSUB nondead,nondead,dead,nondead,nondead
  913.   RETURN
  914. nondead:
  915.   IF oldstate <> deadkeys THEN
  916.      'do nothing
  917.   ELSEIF kd <> undefined THEN
  918.         clr(dedkey)=reverse(clr(dedkey)) 'unhighlight dedkey
  919.         a=dedkey:z=clr(dedkey)       
  920.         GOSUB paintkey
  921.   END IF
  922.   GOSUB textchange
  923.   GOSUB actionchange
  924.   RETURN  
  925. dead:
  926.   IF (kd <> undefined) THEN
  927.      k=kd
  928.      GOSUB highlightk
  929.      IF km <> undefined THEN   'unhighlight modkey
  930.        clr(modkey)=reverse(clr(modkey))
  931.        a=modkey:z=clr(modkey)
  932.        GOSUB paintkey
  933.      END IF
  934.      clr(dedkey) = reverse(clrextract(deadkeys,keys(mustextract,kd,qd)))
  935.      GOSUB drawdedkey
  936.   ELSEIF (kh <> undefined) THEN
  937.      kd = kh
  938.      qd = q
  939.      IF km <> undefined THEN   'unhighlight modkey
  940.        clr(modkey)=reverse(clr(modkey))
  941.        a=modkey:z=clr(modkey)
  942.        GOSUB paintkey
  943.      END IF
  944.      C$(dedkey) = C$(kd)
  945.      clr(dedkey) = reverse(clrextract(deadkeys,keys(mustextract,kd,qd)))
  946.      GOSUB drawdedkey
  947.   END IF
  948.   GOSUB textchange   'does this work
  949.   GOSUB actionchange
  950.   RETURN  
  951. RETURN
  952.  
  953. repaintkeytops:
  954.   qqq=q:IF state < 3 THEN qqq = 0
  955.   st=state:IF st>3 THEN st=3
  956.   keys(st,71,qqq)=keys(st,68,qqq) 
  957.   FOR i=0 TO 103
  958.   IF ulx(i) <> -1 THEN
  959.      z = clrextract(state,keys(st,i,qqq))
  960.      IF i=kh OR (i=71 AND kh=68) THEN z=reverse(z)
  961.      LINE(ulx(i)+1,uly(i)+1)-(lrx(i)-1,lry(i)-1),z,bf
  962.      clr(i)=z
  963.   END IF
  964.   NEXT i
  965.   IF kh <> undefined THEN 
  966.      REM only need to redo key if key active and color changed
  967.      REM or if state has changed
  968.      z=clrextract(state,keys(st,kh,qqq))
  969.      z=reverse(z)
  970.      IF (state <> deadkeys) AND ((z <> clr(modkey)) OR ((120<=k) AND (k<=124))) THEN
  971.         a=modkey
  972.         GOSUB paintkey
  973.         clr(modkey)=z
  974.      END IF
  975.      IF (z <>clr(dedkey)) AND (state = deadkeys) THEN
  976.         a=dedkey
  977.         GOSUB paintkey
  978.         clr(dedkey)=z
  979.      END IF
  980.   END IF
  981.   RETURN  
  982.  
  983. modh:
  984.   BEEP
  985.   RETURN
  986.   
  987. menuh:
  988.     t=MENU(0)
  989.     GOSUB clearlineone
  990.     ON MENU(1) GOTO newk,choice1,choice2,about,quith
  991. newk:
  992.   COLOR white,green:LOCATE 1,1:PRINT "Resetting keymap...";
  993.   GOTO statevariables
  994. choice1:    
  995.   WINDOW 3,"LOAD KEYMAP",(10,20)-(400,75),0,1
  996.   MOUSE OFF:MENU OFF:MENU 1,0,0
  997. emptyinkey1:
  998.   IF INKEY$<>"" THEN emptyinkey1
  999.   PRINT "Load what file? "
  1000.   IF f$<>"" THEN PRINT "Default is ";f$ :ELSE PRINT
  1001.   LINE INPUT ff$
  1002.   IF ff$<>"" THEN fff$=ff$ :ELSE fff$=f$
  1003.   PRINT "Loading keymap ";fff$;"?"
  1004.   PRINT "Press RETURN to accept, any other key to cancel"
  1005. getkey:
  1006.   r$=INKEY$:IF r$ ="" THEN getkey
  1007.   WINDOW CLOSE 3
  1008.   MOUSE ON:MENU ON:MENU 1,0,1
  1009.   GOSUB clearlineone
  1010.   IF r$=CHR$(13) THEN
  1011.      f$=fff$
  1012.   ELSE
  1013.      COLOR white,green:LOCATE 1,1:PRINT "Cancelled":RETURN
  1014.   END IF
  1015.   COLOR white,green:LOCATE 1,1:PRINT "loading keymap... ";f$
  1016.     fff$="devs:keymaps/" + f$
  1017.     GOSUB subopenup
  1018.     GOSUB textchange
  1019.     GOSUB repaintkeytops
  1020.     GOSUB actionchange
  1021.     BEEP
  1022.     RETURN
  1023. choice2:
  1024.     COLOR white,green:LOCATE 1,1:PRINT "saving keymap..."
  1025.     GOTO savekeymap
  1026. about:
  1027.     MOUSE OFF
  1028.     MENU 1,0,0
  1029.     nil=FRE(0)
  1030.     WINDOW 3,"About Keybird  (the keybird enhancer) Version 1.0",(0,8)-(631,186),16,1
  1031.     LOCATE 1,1:COLOR red,white
  1032.     FOR i=1 TO 23:PRINT SPACE$(80):NEXT
  1033.     LOCATE 1,1  
  1034.     PRINT "Default keymap keybird operates on is usa2 (a Dvorak keyboard)"
  1035.     PRINT "  To get the Workbench 1.2 default keymap, use Thisisusa;"
  1036.     PRINT "  make sure you have copied it into the devs:keymaps directory."
  1037.     PRINT "There is a bug in the console.device which causes what you GET from the"
  1038.     PRINT " keyboard to differ from what Keytoy (Extras 1.2 disk, Tools drawer)"
  1039.     PRINT " says you should get.  (Example: CTRL+ALT+B )"
  1040.     PRINT " In this Version, we show what Keytoy says you should get. "
  1041.     PRINT "When typing into the text box at the bottom of the screen,"
  1042.     PRINT " you cannot exceed one character if the highlighted key "
  1043.     PRINT " controls a deadkey or modifiable key."
  1044.     PRINT "Type Help-Alphabetic character to get a high control key (shown in RED)"
  1045.     PRINT "Type Control-Alphabetic character to get ordinary control keys (shown in BLUE)"
  1046.     PRINT "Exceptions:  Type Help-Shift-C TO GET Control-C.   (shown in BLUE)"
  1047.     PRINT "             Type Help-Shift-S to get Control-S.   (shown in BLUE)"
  1048.     PRINT "             Type Help-Shift-M to get Control-M.   (shown in BLUE)"
  1049.     PRINT "             Type Help-Shift-H to get Control-H.   (shown in BLUE)"
  1050.     PRINT "WARNING:  Typing Control-S puts the program to sleep!!!!!"
  1051.     PRINT "  Type any character to wake it up again!"
  1052.     PRINT "Note that program may respond sluggishly to mouse clicks until it warms up.
  1053.     PRINT "Copyright ";CHR$(169);" 1987 by Michael A. Ingrassia, Amicus/HV.  All rights reserved."
  1054.     PRINT "   Licensed for non-commercial distribution (freeware)."
  1055.     PRINT "Press <RETURN> to continue.";
  1056. getkey3:
  1057.     r$=INKEY$:IF r$="" THEN getkey3
  1058.     WINDOW CLOSE 3
  1059.     MOUSE ON
  1060.     MENU 1,0,1
  1061.     RETURN          
  1062.  
  1063. actionh:
  1064.   a=actionkey
  1065.   ON action     GOTO action1,action2,action3,action4,action5,action6
  1066.   ON (action-6) GOTO action7,action8,action9,action10,action11,action12
  1067.   STOP
  1068. action1: 'make capsable
  1069.   keys(capsable,kh,0)=red
  1070.   clr(kh)=lightred
  1071.   GOTO cleanup
  1072. action2: 'make NOT capsable
  1073.   keys(capsable,kh,0)=BLUE
  1074.   clr(kh)=lightblue
  1075.   GOTO cleanup
  1076. action3: 'make repeatable
  1077.   keys(repeatable,kh,0)=red
  1078.   clr(kh)=lightred
  1079.   GOTO cleanup
  1080. action4:  'make NOT repeatable
  1081.   keys(repeatable,kh,0)=BLUE
  1082.   clr(kh)=lightblue
  1083.   GOTO cleanup
  1084. action5: 'make deadkey
  1085.   LOCATE 1,1:PRINT "adding this deadkey   ";
  1086.   CALL adddeadkey(kh,q,0,errcode)
  1087.   IF errcode=-1 THEN BEEP:RETURN 
  1088.   k=kh:GOSUB stalkcheck
  1089.   clr(kh)=lightred
  1090.   GOTO cleanup
  1091. action6: 'make NOT deadkey
  1092.   LOCATE 1,1:PRINT "working on not deadkey";
  1093.   CALL deletedeadkey(kh,q)
  1094.   k=kh:GOSUB stalkcheck
  1095.   clr(kh)=lightblue
  1096.   GOTO cleanup
  1097. action7:  'make modifiable
  1098.   k=kh:GOSUB stalkcheck
  1099.   IF clrextract(keymap,keys(mustextract,kh,q)) <> BLUE THEN
  1100.      COLOR white,green:LOCATE 1,1
  1101.      PRINT "No can do! With some qualifiers this key produces strings!"
  1102.      BEEP:RETURN
  1103.   END IF
  1104.   REM  get next slot in modi$
  1105.   m=1
  1106.   WHILE LEN(modi$(m)) > 0
  1107.     m = m+1
  1108.   WEND
  1109.   REM at this point len(mod$(m)) = 0
  1110.   IF m = maxmod THEN
  1111.      COLOR white,green:LOCATE 1,1
  1112.      PRINT "How embarrassing! There's no room for another modifiable key!";
  1113.      BEEP:RETURN
  1114.   ELSEIF m=nummod+1 THEN
  1115.      nummod = nummod+1
  1116.   END IF
  1117.   m$ = MID$(a$(kh,q),1,1)
  1118.   modi$(m) = m$
  1119.   FOR i=1 TO numdead
  1120.       modi$(m) = modi$(m) + m$
  1121.   NEXT i
  1122.   nil=FRE(0)
  1123.   a$(kh,q) = CHR$(m)
  1124.   keys(mustextract,kh,q)=blue.red.hardblue
  1125.   clr(kh)=lightred
  1126.   GOTO cleanup
  1127. action8:  'make NOT modifiable
  1128.   REM just delete this slot,then redefine nummod if necessary
  1129.   m=ASC(a$(kh,q))
  1130.   a$(kh,q)=MID$(modi$(m),1,1)
  1131.   modi$(m) = ""
  1132.   WHILE LEN(modi$(nummod))=0
  1133.     nummod=nummod-1
  1134.   WEND 
  1135.   keys(mustextract,kh,q)=blue.blue.hardblue 'or should it be softblue?
  1136.   clr(kh)=lightblue
  1137.   k=kh:GOSUB stalkcheck
  1138.   GOTO cleanup
  1139. action9:  'make active
  1140.   IF typ(kh)=undefined THEN
  1141.      typ(kh)=0
  1142.      keys(mustextract,kh,0)=blue.blue.red
  1143.   END IF
  1144.   FOR m=0 TO 3
  1145.    b=exp2(m)
  1146.    IF ((q AND b) <> 0) AND ((typ(kh) AND b) = 0) THEN
  1147.        FOR j=1 TO num(typ(kh))
  1148.          u = use(j,typ(kh)) + b
  1149.          keys(mustextract,kh,u) = blue.blue.red
  1150.        NEXT j
  1151.        typ(kh)=typ(kh)+b
  1152.    END IF
  1153.   NEXT m
  1154.   clr(kh)=reverse(clrextract(keymap,keys(mustextract,kh,q)))
  1155.   k=kh:GOSUB stalkcheck
  1156.   GOTO cleanup
  1157. action10:  'make NOT active
  1158.   FOR j=1 TO num(typ(kh)-q) 'kh may be undefined!?
  1159.     u=use(j,typ(kh)-q) + q
  1160.     IF (keys(mustextract,kh,u)=red.blue.hardblue) OR (keys(mustextract,kh,u)=blue.red.hardblue)  THEN GOTO sorry
  1161.   NEXT j
  1162.   typ(kh)=typ(kh)-q
  1163.   IF q=0 THEN 
  1164.      typ(kh)=undefined  
  1165.      keys(mustextract,kh,0)=black.black.black
  1166.   ELSE   
  1167.    FOR j=1 TO num(typ(kh))
  1168.      u=use(j,typ(kh)) + q
  1169.      keys(mustextract,kh,u)=black.black.black
  1170.    NEXT j
  1171.   END IF
  1172.   k=kh:GOSUB stalkcheck
  1173.   clr(kh)=lightgrey
  1174.   GOTO cleanup
  1175.   sorry:
  1176.     COLOR white,green:LOCATE 1,1
  1177.     PRINT "This keycap controls an active deadkey or modifiable key!"
  1178.     action=11:clr(actionkey)=black
  1179.     C$(actionkey)=actionmsg$(action)
  1180.     a=actionkey:z=clr(actionkey):GOSUB paintkey
  1181.     BEEP
  1182.     RETURN
  1183.   RETURN
  1184. action11:BEEP:RETURN   'unreachable, actually
  1185. action12:              'Make clone of deadkey
  1186.   LOCATE 1,1:PRINT "Cloning deadkey ";C$(km);" ";ml$(qm);
  1187.   CALL adddeadkey(kh,q,deadcode(ASC(a$(km,qm))),errcode)
  1188.   IF errcode=-1 THEN BEEP:RETURN
  1189.   clr(kh)=lightred
  1190.   GOTO cleanup
  1191. cleanup:
  1192.   a=kh:z=clr(kh)
  1193.   GOSUB paintkey 
  1194.   GOSUB textchange
  1195.   GOSUB actionchange
  1196.   GOSUB clearlineone
  1197.   RETURN
  1198.   
  1199. clearlineone:
  1200.   COLOR white,green:LOCATE 1,1
  1201.   PRINT SPACE$(61)
  1202.   RETURN  
  1203.  
  1204. stalkcheck:
  1205. REM paint the stalk for k the proper color
  1206.   IF k=undefined THEN RETURN
  1207.   z=blue.blue.softblue    'default color
  1208.   allshouldbered = false
  1209.   allshouldbehardblue = false
  1210.   C=num(typ(kh) AND 15)  'may be called from savekeymap???
  1211.   j=0
  1212.   WHILE j < C
  1213.     u=use(j+1,typ(kh) AND 15)
  1214.     kk=keys(mustextract,k,u)
  1215.     IF LEN(a$(k,u)) > 1 THEN allshouldbered=true
  1216.     IF kk=red.blue.hardblue THEN allshouldbehardblue=true
  1217.     IF kk=blue.red.hardblue THEN allshouldbehardblue=true    
  1218.     j=j+1
  1219.   WEND
  1220.   IF allshouldbehardblue AND allshouldbered THEN
  1221.      REM  this could happen since stalks grow dynamically
  1222.      j=0:C=num(typ(kh) AND 15)
  1223.      WHILE j < C
  1224.        u=use(j+1,typ(kh) AND 15)
  1225.        kk=keys(mustextract,k,u)
  1226.        IF kk > 3 THEN keys(mustextract,k,u)=blue.blue.hardblue:a$(k,u)=MID$(a$(k,u),1,1):BEEP
  1227.        j=j+1
  1228.      WEND
  1229.   ELSE
  1230.      j=0
  1231.      z=blue.blue.softblue
  1232.      IF allshouldbehardblue THEN z = blue.blue.hardblue
  1233.      IF allshouldbered      THEN z=  blue.blue.red
  1234.      C=num(typ(kh) AND 15)
  1235.      WHILE j < C
  1236.        u=use(j+1,typ(kh) AND 15)
  1237.        kk=keys(mustextract,k,u)
  1238.        IF kk > 3 THEN keys(mustextract,k,u) = z  'skip dead and mod
  1239.        j=j+1
  1240.      WEND
  1241.   END IF
  1242.   st=state:IF st>3 THEN st=3
  1243.   z=reverse(clrextract(keymap,keys(st,kh,q)))
  1244.   IF (clr(kh) <> z) AND (state=keymap) THEN clr(kh)=z:a=kh:GOSUB paintkey
  1245.   RETURN
  1246.   
  1247. actionchange:
  1248. oldaction=action
  1249. IF (kh=undefined) OR (km=undefined) THEN
  1250.    action = 11                         '11 in part
  1251. ELSEIF (state=3) AND (clr(kh)=lightblue) AND (km <> undefined) AND (keys(mustextract,km,qm)=red.blue.hardblue) THEN
  1252.    action = 12
  1253. ELSEIF     (clr(kh)=lightblue) AND (state < 5) THEN
  1254.    action = 2*state - 1                '1,3,5,7
  1255. ELSEIF (clr(kh)=lightred)  AND (state < 5) THEN   
  1256.    action = 2*state                    '2,4,6,8
  1257. ELSEIF (clr(kh)=lightgrey) AND (state = 5) THEN
  1258.    action = 9                          '9
  1259. ELSEIF (clr(kh)=lightgrey)                 THEN
  1260.    action = 11                         '11 in part
  1261. ELSEIF (state = 5)                         THEN
  1262.    IF (clr(kh)<>lightblue) AND (clr(kh)<>lightred) THEN LOCATE 1,1:PRINT "****ABORT***";:STOP
  1263.    IF (q=0) OR (q=1) OR (q=2) OR (q=4) OR (q=8)     THEN
  1264.       action = 10                      '10
  1265.    ELSE
  1266.       action = 11                      '11 in part
  1267.    END IF
  1268. ELSE
  1269.    LOCATE 1,1:PRINT "What's left?":STOP
  1270. END IF
  1271. IF oldaction=action THEN 
  1272.    RETURN
  1273. ELSE   
  1274.   IF action=11 THEN clr(actionkey)=black :ELSE clr(actionkey)=BLUE
  1275.   C$(actionkey)=actionmsg$(action)
  1276.   a=actionkey:z=clr(actionkey)
  1277.   GOSUB paintkey  
  1278. END IF
  1279. RETURN  
  1280.   
  1281. erasededkey:
  1282.   COLOR black,green:LOCATE 15,27:PRINT "    ";
  1283.   COLOR green,green:LINE(ulx(dedkey),uly(dedkey))-(lrx(dedkey),lry(dedkey)),0,bf
  1284.   COLOR black,green:LOCATE 15,36:PRINT ml$(16);
  1285.   RETURN
  1286. drawdedkey:
  1287.   IF (clrextract(deadkeys,keys(mustextract,kd,qd))=red) THEN
  1288.     COLOR black,0:LOCATE 15,27:PRINT "Dead";
  1289.   ELSE
  1290.     COLOR black,0:LOCATE 15,27:PRINT "    ";
  1291.   END IF
  1292.   LINE(ulx(dedkey),uly(dedkey))-(lrx(dedkey),lry(dedkey)),1,b
  1293.   COLOR black,0:LOCATE 15,36:PRINT ml$(qd);
  1294.   a=dedkey:z=clr(dedkey)
  1295.   GOSUB paintkey
  1296.   RETURN  
  1297.  
  1298.  
  1299.  
  1300.  
  1301. qualoff:
  1302.   FOR i=132 TO 135
  1303.     clr(i)=black
  1304.     a=i:z=black
  1305.     GOSUB paintkey
  1306.   NEXT i
  1307.   clr(130)=black:a=130:z=black:GOSUB paintkey
  1308.   clr(131)=black:z=130:z=black:GOSUB paintkey
  1309.   RETURN    
  1310.  
  1311.  
  1312. qualon:
  1313.   FOR i= 135 TO 132 STEP -1
  1314.     IF (q AND exp2(135-i)) <> 0 THEN 
  1315.        clr(i)=red
  1316.     ELSE
  1317.        clr(i)=BLUE
  1318.     END IF
  1319.     a=i:z=clr(i)
  1320.     GOSUB paintkey
  1321.   NEXT i
  1322.   clr(130)=BLUE:a=130:z=BLUE:GOSUB paintkey
  1323.   clr(131)=BLUE:a=131:z=BLUE:GOSUB paintkey
  1324.   RETURN
  1325.  
  1326.   
  1327. showqual:
  1328. REM q is correct but clr(132)-clr(135) may not be
  1329.   IF (q AND 8) <> 0 THEN clr(132)=red :ELSE clr(132)=BLUE
  1330.   IF (q AND 4) <> 0 THEN clr(133)=red :ELSE clr(133)=BLUE
  1331.   IF (q AND 2) <> 0 THEN clr(134)=red :ELSE clr(134)=BLUE
  1332.   IF (q AND 1) <> 0 THEN clr(135)=red :ELSE clr(135)=BLUE
  1333.   FOR i=132 TO 135: a=i:z=clr(i):GOSUB paintkey:NEXT
  1334.   RETURN    
  1335.  
  1336.  
  1337. cycleh:
  1338.   IF k= 131 THEN
  1339.      IF kh=undefined THEN BEEP:RETURN
  1340.      IF (typ(kh) = undefined) THEN BEEP:RETURN
  1341.        j=1
  1342.        gogetit:
  1343.        REM use(j,typ(kh)) can NEVER be 99 here  ??wrongo
  1344.        IF use(j,typ(kh))>q THEN
  1345.           IF use(j,typ(kh)) = 99 THEN q=0 :ELSE q=use(j,typ(kh))
  1346.           GOSUB showqual
  1347.           GOTO cycleout
  1348.        ELSEIF use(j,typ(kh)) = q THEN
  1349.           IF j=num(typ(kh)) THEN q=0:GOSUB showqual:GOTO cycleout    
  1350.           IF j<num(typ(kh)) THEN q=use(j+1,typ(kh)):GOSUB showqual:GOTO cycleout
  1351.        END IF
  1352.        j=j+1
  1353.        GOTO gogetit
  1354. REM  relies very heavily on the fact that for
  1355. REM    a defined key there is NO WAY
  1356. REM    to make keys(state,kh,0)=black
  1357.   END IF
  1358. REM  we are here only if k=130
  1359.      i=135
  1360.      z=BLUE
  1361.      WHILE (z=BLUE) AND (i>=132)   'in effect, this is an adder circuit
  1362.        z=otherchoice(clr(i))
  1363.        a=i
  1364.        GOSUB paintkey
  1365.        clr(i)=z
  1366.        i=i-1
  1367.      WEND
  1368.      q = q + 1
  1369.      IF q=16 THEN q=0
  1370. cycleout:
  1371.   IF (state = deadkeys) THEN
  1372.      qd = q
  1373.      COLOR black,0:LOCATE 15,36:PRINT ml$(q);
  1374.   ELSE     
  1375.      qm = q
  1376.      COLOR black,0:LOCATE 18,36:PRINT ml$(q);
  1377.   END IF
  1378.   GOSUB textchange
  1379.   GOSUB repaintkeytops
  1380.   GOSUB actionchange
  1381. RETURN  
  1382.   
  1383. qualh:
  1384.   b=exp2(135-k)     'b=1,2,4, or 8
  1385.   z=otherchoice(clr(k))
  1386.   a=k
  1387.   GOSUB paintkey
  1388.   clr(k)=z
  1389.   IF z=BLUE THEN q=q-b
  1390.   IF z=red  THEN q=q+b
  1391.   IF (state=deadkeys) THEN
  1392.      qd = q
  1393.      COLOR black,0:LOCATE 15,36:PRINT ml$(q); 
  1394.   ELSE
  1395.      qm = q
  1396.      COLOR black,0:LOCATE 18,36:PRINT ml$(q);
  1397.   END IF
  1398.   GOSUB textchange
  1399.   GOSUB repaintkeytops
  1400.   GOSUB actionchange
  1401.   RETURN  
  1402.   
  1403.     
  1404.   textchange:
  1405. REM  either kh or q has changed
  1406. REM 
  1407. REM  This is the ONLY routine allowed to write
  1408. REM     to loc 18,27
  1409.   IF kh=undefined THEN RETURN
  1410. REM *******************************************************  
  1411. REM Initialize modkey or dedkey as required
  1412. IF (state <> deadkeys)  THEN  'so active site is modkey
  1413.   km = kh
  1414.   qm = q
  1415.   C$(modkey) = C$(kh)
  1416.   st=state:IF st>3 THEN st=3
  1417.   clr(modkey) = reverse(clrextract(state,keys(st,km,qm)))
  1418. ELSE                         'active site is dedkey
  1419.   kd = kh
  1420.   qd = q
  1421.   C$(dedkey) = C$(kh)
  1422.   clr(dedkey) = reverse(clrextract(deadkeys,keys(mustextract,kh,q)))  
  1423. END IF
  1424. REM *******************************************************
  1425. REM Define kmt and kdt 
  1426. REM kmt = 1 if km,qm  is an ordinary key
  1427. REM kmt = 2 if km,qm  is a  modifiable key
  1428. REM kmt = 3 if km,qm  is a  deadkey
  1429. REM kdt = 1 if kd,qd  is an ordinary key  or a modifiable key
  1430. REM kdt = 3 if kd,qd  is a  deadkey 
  1431. REM kdc = deadkeycode if kd,qd is a deadkey
  1432. REM kdc = 0 if kd,qd  is not a deadkey
  1433.     kmt=undefined:kdt = undefined
  1434. IF (km <> undefined) THEN
  1435.    IF clrextract(deadkeys,keys(mustextract,km,qm))=red THEN
  1436.        kmt = 3
  1437.    ELSEIF clrextract(modifiable,keys(mustextract,km,qm))=red THEN
  1438.        kmt = 2
  1439.    ELSE 
  1440.        kmt = 1
  1441.    END IF
  1442. END IF
  1443. IF (kd <> undefined) THEN
  1444.    IF clrextract(deadkeys,keys(mustextract,kd,qd))=red THEN
  1445.       kdt = 3
  1446.    ELSE
  1447.       kdt = 1
  1448.    END IF
  1449. END IF
  1450. IF kdt=3 THEN kdc=deadcode(ASC(a$(kd,qd))) :ELSE kdc=0   
  1451. REM *********************************************************   
  1452. REM drawdedkey or erasededkey as required
  1453. IF (kdt <> undefined) THEN
  1454.    IF ((state=deadkeys) OR ((kdt=3)AND(kmt=2))) THEN
  1455.          GOSUB drawdedkey
  1456.          COLOR black,0:LOCATE 18,27:PRINT "Mod ";
  1457.    ELSE
  1458.          GOSUB erasededkey
  1459.    END IF
  1460. END IF
  1461. REM *********************************************************
  1462. REM draw message for modkey as required
  1463. IF  kmt=undefined THEN
  1464.     COLOR black,0:LOCATE 18,27:PRINT "    ";
  1465. ELSEIF kmt = 1 THEN
  1466.     COLOR black,0:LOCATE 18,27:PRINT "Use ";
  1467. ELSEIF kmt = 2 THEN
  1468.     COLOR black,0:LOCATE 18,27:IF kdt=3 THEN PRINT "Mod "; :ELSE PRINT "Use ";         
  1469. ELSE  'kmt = 3 
  1470.     COLOR black,0:LOCATE 18,27:PRINT "Dead";
  1471. END IF
  1472. REM ********************************************************
  1473.   a=modkey:z=clr(modkey)
  1474.   GOSUB paintkey
  1475.   COLOR black,green:LOCATE 18,36:PRINT ml$(qm);
  1476. REM ******************************************************  
  1477. REM ******************************************************
  1478. REM  problem in next line--km might be undefined!!
  1479.   IF km<>undefined THEN clr(textkey) = reverse(clrextract(keymap,keys(mustextract,km,qm)))  
  1480. IF (kmt=2) THEN
  1481.   C$(textkey) = MID$(modi$(ASC(a$(km,qm))),kdc+1,1) '+SPACE$(31)
  1482. ELSEIF kmt=3 THEN
  1483.   C$(textkey)= "--dead--" ' + SPACE$(24)
  1484. ELSEIF kmt=undefined THEN
  1485.   C$(textkey)= "--no base key--" '+SPACE$(9)
  1486. ELSE  
  1487.   C$(textkey) = a$(km,qm)  '+MID$(ml$(16),1,32-LEN(a$(km,qm))) 
  1488. END IF
  1489. REM pad with blanks
  1490.   a=textkey:z=clr(textkey)
  1491.   GOSUB paintkey
  1492.   COLOR black,z:LOCATE 21,32+LEN(C$(textkey)):PRINT "*";
  1493.   RETURN
  1494.   
  1495. texth:
  1496.   x$=r$  
  1497.   x=ASC(x$)
  1498.   IF helpstatus=inactive AND x=139 THEN 
  1499.     helpstatus=active
  1500.     RETURN
  1501.   END IF  
  1502.   IF helpstatus=active THEN
  1503.      IF x=83 THEN        'help-Shift-S
  1504.       x$=CHR$(19):x=19   '  becomes Ctrl-S (suspends)
  1505.      ELSEIF x=72  THEN   'help-Shift-H
  1506.       x$=CHR$(8):x=8     '  becomes Ctrl-H (backspaces)
  1507.      ELSEIF x=67  THEN   'help-Shift-C
  1508.       x$=CHR$(3):x=3     '  becomes Ctrl-C (terminates)
  1509.      ELSEIF x=77  THEN   'help-Shift-M
  1510.       x$=CHR$(13):x=13   '  becomes Ctrl-M (returns)
  1511.      ELSE
  1512.        x=(x AND 159) OR 128
  1513.        x$=CHR$(x)        '  becomes control character with high bit set
  1514.      END IF
  1515.   END IF   
  1516. there:
  1517.   IF (x=13) AND (helpstatus=inactive) THEN  'I. Return pressed
  1518.      IF (kmt=undefined) OR (kmt=3) THEN     'I.A.  No key!
  1519.         BEEP
  1520.      ELSEIF kmt=1 THEN                      'I.B  ordinary key
  1521.         a$(km,qm)=text$                     'I.B.i. longtext
  1522.         IF (LEN(text$)>1) AND ((keys(mustextract,km,qm)=blue.blue.softblue) OR (keys(mustextract,km,qm)=blue.blue.red)) THEN
  1523.            C=num(typ(km))
  1524.            m=0
  1525.            WHILE m<C
  1526.              u=use(m+1,typ(km))
  1527.              keys(mustextract,km,u)=blue.blue.red
  1528.              m=m+1
  1529.            WEND                             'I.B.ii. longtext, illegal
  1530.         ELSEIF (LEN(text$)>1) AND (keys(mustextract,km,qm)=blue.blue.hardblue) THEN
  1531.            BEEP:a$(km,qm)=MID$(text$,1,1)
  1532.         END IF
  1533.                                             'I.B.i.  longtext, legal
  1534.         IF (state=keymap) AND (LEN(a$(km,qm))>1) AND (clr(kh) <> lightred) THEN
  1535.            clr(kh)=lightred:a=kh:z=clr(kh):GOSUB paintkey
  1536.            clr(modkey)=lightred:a=modkey:z=clr(modkey):GOSUB paintkey
  1537.            clr(textkey)=lightred:a=textkey:z=lightred:GOSUB paintkey
  1538.         ELSEIF (LEN(a$(km,qm))=1)  THEN     'I.B.ii. shortext
  1539.            k=km:GOSUB stalkcheck
  1540.         END IF
  1541.         C$(textkey)=a$(km,qm)               'I.C modifiable key
  1542.      ELSEIF kmt=2 THEN  'modifiable key, return pressed
  1543.         IF LEN(text$)=0 THEN                'I.C.i. notext
  1544.            BEEP
  1545.         ELSE                                'I.C.ii. longtext
  1546.            IF LEN(text$)>1 THEN BEEP:text$=MID$(text$,1,1)
  1547.            a=ASC(a$(km,qm))
  1548.            MID$(modi$(a),kdc+1,1) = text$
  1549.         END IF
  1550.         C$(textkey)=text$         
  1551.      END IF
  1552.      text$=""
  1553.      GOSUB textchange              'II.  Backspace
  1554.   ELSEIF (x=8) AND (helpstatus=inactive) THEN  'backspace
  1555.      IF LEN(text$)=0 THEN
  1556.        BEEP
  1557.      ELSE
  1558.        text$=MID$(text$,1,LEN(text$)-1)
  1559.        COLOR black,clr(textkey):LOCATE texty,textx+LEN(text$)
  1560.        PRINT " ";
  1561.      END IF
  1562.                            'III.  Not an Edit Key
  1563.   ELSE  'no special meaning for key; not return or backspace
  1564.    IF keys(mustextract,km,qm)=blue.blue.hardblue THEN
  1565.        text$=x$
  1566.        CALL printt(text$,1)
  1567.    ELSE  
  1568.        text$=MID$(text$,1,31)+x$
  1569.        CALL printt(text$,LEN(text$))
  1570.    END IF
  1571.   END IF
  1572.   helpstatus=inactive
  1573.   RETURN
  1574.  
  1575. subprintt:  
  1576. SUB printt(text$,start) STATIC
  1577. SHARED texty,textx,BLUE,lightgrey,red,textkey
  1578.  back = clr(textkey)
  1579.  LOCATE texty,textx+start-1
  1580.  fore = lightgrey
  1581.  FOR i=start TO LEN(text$)
  1582.    y$=MID$(text$,i,1)
  1583.    y=ASC(y$)
  1584. colors:
  1585.    IF y < 32 THEN
  1586.       COLOR BLUE,back:PRINT  CHR$(y+64);
  1587.    ELSEIF y < 128 THEN
  1588.       COLOR fore,back:PRINT y$;
  1589.    ELSEIF y < 160 THEN
  1590.       COLOR red,back:PRINT CHR$(y-64);
  1591.    ELSE
  1592.       COLOR fore,back:PRINT y$;
  1593.    END IF
  1594.  NEXT i
  1595.  END SUB
  1596.  
  1597. breakh:
  1598.  s$=CHR$(3)
  1599.  RETURN 
  1600.  
  1601. quith:
  1602.  GOSUB clearlineone
  1603.  COLOR white,green:LOCATE 1,1:PRINT "Stopped on request";SPACE$(15)
  1604.  WINDOW CLOSE 2:SCREEN CLOSE 1
  1605.  MENU RESET
  1606.  SYSTEM
  1607.  STOP 
  1608.  
  1609. diskerrorh:
  1610.   WINDOW OUTPUT 2
  1611.   WINDOW 3,,,0,1  'the purpose is to
  1612.   WINDOW CLOSE 3 'force our screen front
  1613.   errno=ERR
  1614.   x=errno
  1615.   GOSUB clearlineone
  1616.   COLOR 3,0:LOCATE 1,1:PRINT x
  1617.   LOCATE 1,1
  1618.   IF x=53 THEN
  1619.      PRINT "I can't find file ";:COLOR 3,1:PRINT f$;
  1620.      COLOR white,green
  1621.   ELSEIF x=55 THEN
  1622.      PRINT "But the file is already open!";
  1623.   ELSEIF x=57 THEN
  1624.      PRINT "Fatal device I/O Error";
  1625.   ELSEIF x=61 THEN
  1626.      PRINT "All disk storage space is in use.  Make more room.";
  1627.   ELSEIF x=64 THEN
  1628.      PRINT "Filename is illegal.  (Too many characters?)";
  1629.   ELSEIF x=67 THEN
  1630.      PRINT "Too many files open.";
  1631.   ELSEIF x=68 THEN
  1632.      PRINT "The device specified is not available at this time.";
  1633.   ELSEIF x=70 THEN
  1634.      PRINT "The disk is write protected.  Please move the little tab.";
  1635.   ELSEIF x=74 THEN
  1636.      PRINT "The volume specified has not been mounted.";
  1637.   ELSE
  1638.      PRINT "Mysterious error.  Didn't work.";
  1639.   END IF
  1640.   RESUME NEXT
  1641.  
  1642. savekeymap:
  1643.   MOUSE OFF:MENU OFF:MENU 1,0,0
  1644.   bri4=0
  1645.   WINDOW 3,"SAVE KEYMAP",(10,20)-(400,75),0,1
  1646. emptyinkey:
  1647.   IF INKEY$<>"" THEN emptyinkey
  1648.   PRINT "Save as what file? "
  1649.   IF f$<>"" THEN PRINT "Default is ";f$ :ELSE PRINT
  1650.   LINE INPUT ff$
  1651.   IF ff$<>"" THEN fff$=ff$ :ELSE fff$=f$
  1652.   PRINT "Saving keymap as ";fff$;"?"
  1653.   PRINT "Press RETURN to accept, any other key to cancel"
  1654. getkey2:
  1655.   r$=INKEY$:IF r$ ="" THEN getkey2
  1656.   WINDOW CLOSE 3
  1657.   MOUSE ON:MENU ON:MENU 1,0,1
  1658.   GOSUB clearlineone
  1659.   IF r$=CHR$(13) THEN
  1660.      f$=fff$
  1661.   ELSE
  1662.      COLOR white,green:LOCATE 1,1:PRINT "Cancelled":RETURN
  1663.   END IF
  1664.   COLOR white,green:LOCATE 1,1:   PRINT "            Saving ";f$
  1665.   bi=10+36+15+15+120+4*120     'first free space
  1666.   LOCATE 1,1:PRINT "zeroes     ":GOSUB writezeroes
  1667.   LOCATE 1,1:PRINT "addresses  ":GOSUB writeaddresses
  1668.   LOCATE 1,1:PRINT "capsable   ":p=capsable:GOSUB writebittable
  1669.   LOCATE 1,1:PRINT "repeatable ":p=repeatable:GOSUB writebittable
  1670.   LOCATE 1,1:PRINT "keytypes   ":GOSUB writekeytypes
  1671.   LOCATE 1,1:PRINT "keymap     ":GOSUB writekeymap
  1672.   GOSUB writefile:
  1673.   BEEP
  1674.   MOUSE ON
  1675.   RETURN
  1676.  
  1677. writezeroes:
  1678.   FOR j=0 TO 9:buff(j)=0:NEXT j
  1679.   RETURN
  1680.  
  1681. writeaddresses:
  1682.   RESTORE addresslist
  1683.   FOR i=0 TO 8:FOR j=0 TO 3:READ buff(10+4*i+j):NEXT j:READ comment$:NEXT i
  1684. addresslist:
  1685.   DATA  00,00,00, 00,        name (dummy entries)
  1686.   DATA  00,00,00, 76,        lokeytypes
  1687.   DATA  00,00,00,196,        lokeymap
  1688.   DATA  00,00,00, 46,        locapsable
  1689.   DATA  00,00,00, 61,        lorepeatable
  1690.   DATA  00,00,00,140,        hikeytypes
  1691.   DATA  00,00,01,196,        hikeymap
  1692.   DATA  00,00,00, 54,        hicapsable
  1693.   DATA  00,00,00, 69,        hirepeatable 
  1694.   RETURN
  1695.   
  1696. writebittable:
  1697.   IF p=capsable   THEN pbase = 10+36
  1698.   IF p=repeatable THEN pbase = 10+36+15
  1699.   FOR i=0 TO 14
  1700.     d=0
  1701.     FOR j=8*i+7 TO 8*i STEP -1
  1702.       IF keys(p,j,0)=BLUE THEN b=0 :ELSE b=1  'p=1 or 2 always
  1703.       d=2*d+b
  1704.     NEXT j
  1705.     buff(pbase+i)=d
  1706.   NEXT i
  1707. RETURN
  1708.       
  1709. writekeytypes:
  1710.   keytype=10+36+15+15
  1711.   FOR i=0 TO 119
  1712.   IF typ(i)=undefined THEN
  1713.     typ(i)=128
  1714.   ELSE
  1715.    ' GOSUB stalkcheck  should be unnecessary 
  1716.     C=num(typ(i))
  1717.     litmus=clrextract(keymap,keys(mustextract,i,0))
  1718.     IF litmus = BLUE THEN   'all entries 1 character
  1719.       REM check if this keycap has a modkey or deadkey
  1720.       modhere=false
  1721.       j=0
  1722.       WHILE NOT modhere AND (j<C)   
  1723.         u=use(j+1,typ(i))
  1724.         IF keys(mustextract,i,u)=blue.red.hardblue THEN modhere=true
  1725.         IF keys(mustextract,i,u)=red.blue.hardblue THEN modhere=true
  1726.         j=j+1
  1727.       WEND  
  1728.       IF modhere THEN
  1729.         typ(i)=typ(i) OR 32
  1730.       ELSEIF C <=4 THEN
  1731.         typ(i)=typ(i)     'nochange
  1732.       ELSEIF typ(i)=7 THEN
  1733.         REM check for vanilla; note c=8
  1734.         vanilla=true
  1735.         FOR j=0 TO 3
  1736.           IF (ASC(a$(i,j)) AND 159) <> ASC(a$(i,j+4)) THEN vanilla=false
  1737.         NEXT j
  1738.         IF NOT vanilla THEN typ(i)=typ(i) OR 64
  1739.       ELSE 'c > 4  
  1740.         typ(i)=typ(i) OR 16  'temporary marker--bit otherwise unused
  1741.       END IF
  1742.     ELSE   'litmus=red      must be handled as string
  1743.       typ(i)=typ(i) OR 64
  1744.     END IF
  1745.   END IF
  1746.   buff(keytype+i)=typ(i) AND 239 'must turn off temporary marker
  1747.   NEXT i     
  1748.   RETURN
  1749.   
  1750. writekeymap:
  1751.   FOR i=0 TO 119
  1752.     IF     (typ(i) AND 16)  <> 0 THEN
  1753.        GOSUB writedirect
  1754.     ELSEIF (typ(i) AND 32)  <> 0 THEN
  1755.        GOSUB writemodstring
  1756.     ELSEIF (typ(i) AND 64)  <> 0 THEN
  1757.        GOSUB writestring
  1758.     ELSEIF (typ(i) AND 128) <> 0 THEN      
  1759.        add = 10+36+15+15+120+4*i
  1760.        FOR j=0 TO 3
  1761.          buff(add+j)=0
  1762.        NEXT j
  1763.        typ(i)=undefined
  1764.    ELSE
  1765.       GOSUB writeimmediate
  1766.    END IF
  1767.   NEXT i
  1768.   RETURN 
  1769.   
  1770. writedirect:
  1771.   GOSUB writepointer
  1772.   typ(i)=typ(i) AND 15
  1773.   C=num(typ(i))
  1774.   FOR j=0 TO C-1
  1775.     u=use(j+1,typ(i))
  1776.     buff(bi+j)=ASC(a$(i,u)) 'should be only 1 character 
  1777.   NEXT j
  1778.   bi=bi+C
  1779.   RETURN 
  1780.   
  1781. writeimmediate:
  1782.   add=10+36+15+15+120+4*i
  1783.   FOR j=0 TO 3:temp(j)=0:NEXT j
  1784.   C=num(typ(i)):IF typ(i)=7 THEN C=4 'handles vanilla case; note c<5
  1785.   FOR j=0 TO C-1
  1786.     u=use(j+1,typ(i))
  1787.     temp(3-j)=ASC(a$(i,u)+CHR$(0))
  1788.   NEXT j
  1789.   FOR j=0 TO 3:buff(add+j)=temp(j):NEXT j  
  1790.   RETURN    
  1791.   
  1792. writestring:
  1793.   GOSUB writepointer
  1794.   typ(i)=typ(i) AND 15
  1795.   C=num(typ(i))   'string descriptor has length 2*c
  1796.   s=bi + 2*C
  1797.   FOR j=0 TO C-1
  1798.     u=use(j+1,typ(i))
  1799.     buff(bi+2*j)   =LEN(a$(i,u))
  1800.     buff(bi+2*j+1) =s-bi    'offset
  1801.     FOR m=1 TO LEN(a$(i,u))
  1802.       buff(s)=ASC(MID$(a$(i,u),m,1))
  1803.       s=s+1
  1804.     NEXT m 
  1805.   NEXT j
  1806.   bi = s
  1807.   RETURN
  1808.   
  1809. writemodstring:
  1810.   GOSUB writepointer
  1811.   typ(i)=typ(i) AND 15
  1812.   C=num(typ(i))  'string descriptor has length 2*c
  1813.   s=bi + 2*C
  1814.   FOR j=0 TO C-1
  1815.     u=use(j+1,typ(i))
  1816.     IF keys(mustextract,i,u)=blue.red.hardblue THEN
  1817.        buff(bi+2*j)   = 1
  1818.        buff(bi+2*j+1) = s - bi
  1819.        a=ASC(a$(i,u))
  1820.        FOR m=1 TO LEN(modi$(a))
  1821.          buff(s)=ASC(MID$(modi$(a),m,1))
  1822.          s=s+1
  1823.        NEXT m
  1824.     ELSEIF keys(mustextract,i,u)=red.blue.hardblue THEN
  1825.       buff(bi+2*j)   = 8
  1826.       buff(bi+2*j+1) = deadcode(ASC(a$(i,u)))
  1827.     ELSE   'ordinary
  1828.       buff(bi+2*j)   = 0
  1829.       buff(bi+2*j+1) = ASC(a$(i,u)) 'should be only 1 character
  1830.     END IF
  1831.   NEXT j
  1832.   bi = s
  1833.  
  1834.   RETURN
  1835.   
  1836. writepointer:
  1837.   x$=MKL$(bi)   'convert to 4 byte string
  1838.   add=10+36+15+15+120+4*i
  1839.   FOR j=0 TO 3:buff(add+j)=ASC(MID$(x$,j+1,1)):NEXT j
  1840.   add$=MKL$(add)
  1841.   buffreloc$(bri4) = add$
  1842.   bri4=bri4+1
  1843.   RETURN  
  1844.   
  1845. writefile:
  1846.   add=bi   'save address of name of keymap temporarily
  1847.   FOR i=1 TO LEN(f$)
  1848.     buff(bi)=ASC(MID$(f$,i,1))
  1849.     bi=bi+1
  1850.   NEXT i
  1851.   buff(bi)=0
  1852.   bi=bi+1
  1853.   WHILE (bi MOD 4) <> 0
  1854.     buff(bi)=0
  1855.     bi=bi+1
  1856.   WEND
  1857.   bi4=bi/4 
  1858.   bi4$=MKL$(bi4)
  1859.   add$=MKL$(add)
  1860.   REM  put address of name where it belongs
  1861.   FOR j=0 TO 3:buff(10+j)=ASC(MID$(add$,j+1,1)):NEXT j
  1862.   REM *************************************************
  1863.   REM now write the actual file out
  1864.   fff$="devs:keymaps/"+f$
  1865.   ON ERROR GOTO diskerrorh:errno=0
  1866.   OPEN fff$ FOR OUTPUT AS #1
  1867.   IF errno <> 0 THEN  ON ERROR GOTO 0:RETURN
  1868.   PRINT #1,MKL$(1011);    'hunk-header   $000003F3
  1869.   PRINT #1,MKL$(0);       '  no names
  1870.   PRINT #1,MKL$(1);       '  table size is 1
  1871.   PRINT #1,MKL$(0);       '  first hunk is 0
  1872.   PRINT #1,MKL$(0);       '  last hunk  is 0
  1873.   PRINT #1,bi4$;          '  size of hunk-code
  1874.   PRINT #1,MKL$(1001);    'hunk-code     $000003E9
  1875.   PRINT #1,bi4$;
  1876.   FOR i=0 TO bi-1:PRINT #1,CHR$(buff(i));:NEXT i
  1877.   PRINT #1,MKL$(1004);    'hunk-reloc32  $000003EC
  1878.   PRINT #1,MKL$(bri4+9);  '  number of references to be relocated
  1879.   PRINT #1,MKL$(0);       '  hunk #0
  1880.   FOR i= bri4 - 1 TO 0 STEP -1
  1881.     PRINT #1,buffreloc$(i);  'the pointers we've inserted
  1882.   NEXT i  
  1883.   FOR i=8 TO 0 STEP -1
  1884.     PRINT #1,MKL$(10+4*i);  'the 9-address table
  1885.   NEXT i
  1886.   PRINT #1,MKL$(0);        'termination signal
  1887.   PRINT #1,MKL$(1010);     'hunk-end     $000003F2
  1888.   CLOSE #1
  1889.   ON ERROR GOTO 0
  1890.   GOSUB clearlineone
  1891.   LOCATE 1,1:PRINT "Finished "
  1892.   RETURN    
  1893.